;;; Copyright 2010 Alessio Stalla.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;      http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package :spring-impl)

(require :java-collections)

(defconstant true (make-immediate-object t :boolean))
(defconstant false (make-immediate-object nil :boolean))
(defconstant null (make-immediate-object nil :ref))

(defun true? (x)
  (and x :todo))

(defvar *application-context* nil)
(defvar *bean-definition-reader* nil "The instance of LispBeanDefinitionReader used to hold configuration and load bean definitions.")
(defvar *bean-factory* nil "The bean factory. Must be an instance of DefaultListableBeanFactory. Provided by the LispBeanDefinitionReader via JSR-223 bindings.")
(defvar *load-resource* nil "Resource from which the current application context is being loaded. Can be NIL when the source is not known.")

(defun parent-application-context (&optional (ctx *application-context*))
  (jcall "getParent" ctx))

(defun parent-bean-factory (&optional (bf *bean-factory*))
  (jcall "getParentBeanFactory" bf))

(defun bean-definition-names (&optional (bf *bean-factory*))
  (jcall "getBeanDefinitionNames" bf))

(defun singleton-names (&optional (bf *bean-factory*))
  (jcall "getSingletonNames" bf))

(defun get-singleton (name &optional (bf *bean-factory*))
  (jcall "getSingleton" bf name))

(defun get-bean-definition (name &optional (bf *bean-factory*))
  (jcall "getBeanDefinition" bf name))

(defun bean-definition-class (bdef)
  (jcall "getBeanClass" bdef))

(defun bean-definition-class-name (bdef)
  (let ((class (ignore-errors (bean-definition-class bdef))))
    (if class
        (jclass-name class)
        (jcall "getBeanClassName" bdef))))

(defun get-bean (name &optional (ctx *application-context*))
  (jcall "getBean" ctx name))

(defun register-bean-definition (name def &optional (bean-factory *bean-factory*))
  "Registers a bean definition on the factory."
  (jcall "registerBeanDefinition" bean-factory name def)
  def)

(defun register-singleton (name object &optional (bean-factory *bean-factory*))
  "Registers a bean on the factory."
  (let ((object (convert-value object)))
    (jcall "registerSingleton" bean-factory name object)
    object))

(defun make-bean-definition (class &key constructor-args properties parent
                             init-method destroy-method scope factory-bean
                             factory-method autowire-mode listeners
                             post-processor (abstract nil abstract-provided-p)
                             (lazy-init nil lazy-init-provided-p) depends-on
                             autowire-candidate primary)
  (let ((bdef (jnew "org.springframework.beans.factory.support.GenericBeanDefinition")))
    (if (stringp class)
        (setf (jproperty-value bdef "beanClassName") class)
        (setf (jproperty-value bdef "beanClass") class))
    (when constructor-args
      (setf (jproperty-value bdef "constructorArgumentValues")
            constructor-args))
    (when properties
      (setf (jproperty-value bdef "propertyValues") properties))
    (when parent (setf (jproperty-value bdef "parentName") parent))
    (when init-method
      (setf (jproperty-value bdef "initMethodName") init-method))
    (when destroy-method
      (setf (jproperty-value bdef "destroyMethodName") destroy-method))
    (when scope (setf (jproperty-value bdef "scope") scope))
    (when factory-bean
      (setf (jproperty-value bdef "factoryBeanName") factory-bean))
    (when factory-method
      (setf (jproperty-value bdef "factoryMethodName") factory-method))
    (when autowire-mode
      (setf (jproperty-value bdef "autowireMode")
            (jfield "org.springframework.beans.factory.support.AbstractBeanDefinition"
                    (case autowire-mode
                      (:no "AUTOWIRE_NO")
                      (:by-name "AUTOWIRE_BY_NAME")
                      (:by-type "AUTOWIRE_BY_TYPE")
                      (:constructor "AUTOWIRE_CONSTRUCTOR")
                      (:autodetect "AUTOWIRE_AUTODETECT")
                      (t (error "Unsupported autowire mode: ~A" autowire-mode))))))
    (when *load-resource*
      (setf (jproperty-value bdef "resource") *load-resource*))
    (when listeners
      (jcall "setAttribute" bdef
             (jfield "dynaspring.LispBeanFactory" "LISTENERS_ATTRIBUTE")
             listeners))
    (when post-processor
      (jcall "setAttribute" bdef
             (jfield "dynaspring.LispBeanFactory" "POSTPROCESSOR_ATTRIBUTE")
             post-processor))
    (when abstract-provided-p
      (jcall "setAbstract" bdef (jbool abstract)))
    (when lazy-init-provided-p
      (jcall "setLazyInit" bdef (jbool lazy-init)))
    (when depends-on
      (let ((depends-on (ensure-list depends-on)))
        (jcall "setDependsOn" bdef (list->jarray depends-on))))
    (when autowire-candidate
      (jcall "setAutowireCandidate" bdef (jbool autowire-candidate)))
    (when primary
      (jcall "setPrimary" bdef (jbool primary)))
    bdef))

(defun ref (bean)
  (let ((ref (jnew (jconstructor "org.springframework.beans.factory.config.RuntimeBeanReference" "java.lang.String")
                   bean)))
    ref))

(defun constructor-arg (obj &optional type)
  (jnew (jconstructor "org.springframework.beans.factory.config.ConstructorArgumentValues$ValueHolder"
                      "java.lang.Object" "java.lang.String")
        (convert-value obj) type))

(defun constructor-args (&rest args)
  (let ((list (jnew (jconstructor "org.springframework.beans.factory.config.ConstructorArgumentValues"))))
    (dolist (x args)
      (if (jinstance-of-p x "org.springframework.beans.factory.config.ConstructorArgumentValues$ValueHolder")
          (jcall (jmethod "org.springframework.beans.factory.config.ConstructorArgumentValues" "addGenericArgumentValue" "org.springframework.beans.factory.config.ConstructorArgumentValues$ValueHolder")
                 list x)
          (jcall (jmethod "org.springframework.beans.factory.config.ConstructorArgumentValues" "addGenericArgumentValue" "java.lang.Object")
                 list (convert-value x))))
    list))

(defun to-java-name (name)
  (etypecase name
    (string name)
    (symbol (dashed->camelcased name))))

(defun property-value (name obj)
  (jnew (jconstructor "org.springframework.beans.PropertyValue" "java.lang.String" "java.lang.Object")
        (to-java-name name)
        (convert-value obj)))

(defun property-values (&rest args)
  (let ((list (jnew (jconstructor "org.springframework.beans.MutablePropertyValues"))))
    (dolist (x args)
      (jcall (jmethod "org.springframework.beans.MutablePropertyValues"
                      "addPropertyValue"
                      "org.springframework.beans.PropertyValue")
             list
             (if (jinstance-of-p x "org.springframework.beans.PropertyValue")
                 x
                 (property-value (car x) (cadr x)))))
    list))

(defun convert-value (obj)
  (cond
    ((listp obj)
      (let ((list (jnew "org.springframework.beans.factory.support.ManagedList"))
            (index -1))
        (dolist (x obj)
          (jcall "add" list (incf index) (convert-value x)))
        list))
    ((hash-table-p obj)
      (let ((map (jnew "org.springframework.beans.factory.support.ManagedMap")))
        (maphash (lambda (key value) (jcall "put" map (convert-value key)
                                            (convert-value value)))
                 obj)
        map))
    ((eq obj t) true)    
    (t obj))) ;;TODO

(defun dashed->camelcased (string-designator)
  "Transforms a name (string designator) from the Lisp naming convention of separating multiple words with dashes to the Java camelCase convention."
  (let ((str (string string-designator))
        (last-was-dash-p nil))
    (with-standard-io-syntax
      (with-output-to-string (out)
        (cl:map nil (lambda (ch)
                      (if (char= #\- ch)
                          (setq last-was-dash-p t)
                          (if last-was-dash-p
                              (progn
                                (princ (char-upcase ch) out)
                                (setq last-was-dash-p nil))
                              (princ (char-downcase ch) out))))
                str)))))

(defmacro bean (class &key constructor-args properties parent
                init-method destroy-method scope factory-bean factory-method
                autowire-mode listeners post-processor depends-on
                (abstract nil abstract-provided-p)
                (lazy-init nil lazy-init-provided-p)
                autowire-candidate primary)
  `(make-bean-definition
    ,class
    :constructor-args (constructor-args ,@constructor-args)
    :properties (property-values ,@(loop
                                     :for name :in properties :by #'cddr
                                     :for value :in (cdr properties) :by #'cddr
                                     :collect `(list ,name ,value)))
    :parent ,parent
    :init-method ,init-method
    :destroy-method ,destroy-method
    :scope ,scope
    :factory-bean ,factory-bean
    :factory-method ,factory-method
    :autowire-mode ,autowire-mode
    :listeners ,(when listeners `(convert-value (list ,@listeners)))
    :post-processor ,post-processor
    :depends-on ,depends-on
    ,@(when abstract-provided-p `(:abstract ,abstract))
    ,@(when lazy-init-provided-p `(:lazy-init ,lazy-init))
    :autowire-candidate ,autowire-candidate
    :primary ,primary))

(defmacro defbean (name class &rest args)
  `(register-bean-definition ,(to-java-name name) (bean ,class ,@args)))

(defun map (&rest args)
  (let ((map (make-hash-table)))
    (loop
      :for key :in args :by #'cddr
      :for val :in (cdr args) :by #'cddr
      :do (setf (gethash key map) val))
    map))

(defun props (&rest args)
  (let ((props (jnew "java.util.Properties")))
    (loop
       :for key :in args :by #'cddr
       :for val :in (cdr args) :by #'cddr
       :do (jcall "put" props (to-java-name key) (string val)))
    props))

(defun set (&rest args)
  (let ((set (jnew "org.springframework.beans.factory.support.ManagedSet")))
    (dolist (x args)
      (jcall "add" set x))
    set))

;;Utilities
(defun ensure-list (obj)
  (if (listp obj) obj (list obj)))

(defun ensure-ref (name-or-ref)
  (if (stringp name-or-ref)
      (ref name-or-ref)
      name-or-ref))

(defun list->jarray (list)
  (let ((array (jnew-array "java.lang.Object" (length list)))
        (i 0))
    (dolist (x list)
      (setf (jarray-ref array i) x)
      (incf i))
    array))

(defun load-configuration (&rest resources)
  (let ((array (list->jarray resources)))
    (jcall "loadConfiguration" (configuration) *application-context* array)))

(defun configuration ()
  (jcall "getConfiguration" *bean-definition-reader*))

(defun getprop (name &optional (props (configuration)))
  (jcall "getProperty" props name))

(defun putprop (name value &optional (props (configuration)))
  (jcall "setProperty" props name value)
  value)

(defun jbool (value) ;TODO check if it's already a boolean!
  (make-immediate-object (not (not value)) :boolean))

(defun replace-placeholders
    (value conf &optional (ignore-unresolvable-placeholders-p t))
  (jcall "replacePlaceholders" conf value (jbool ignore-unresolvable-placeholders-p)))

(defun placeholder-reader (stream char)
  (declare (ignore char))
  (let ((ch (read-char stream)))
    (unless (char= ch #\{)
      (error "Unexpected character after $: ~A" ch))
    (ignore-errors
      (replace-placeholders
       (with-output-to-string (str)
         (princ "${" str)
         (loop
            :for ch := (read-char stream) :then (read-char stream)
            :while (not (char= ch #\}))
            :do (write-char ch str))
         (write-char #\} str))
       (configuration)
       nil))))

(set-macro-character #\$ #'placeholder-reader t)

(defun default-resource-loader ()
  (if *bean-definition-reader*
      (jcall "getResourceLoader" *bean-definition-reader*)
      (jnew "org.springframework.core.io.DefaultResourceLoader")))

(defun resourcep (res)
  (jinstance-of-p res "org.springframework.core.io.Resource"))

(defun resource (res &optional (resloader (default-resource-loader)))
  (if (resourcep res)
      res
      (jcall "getResource" resloader res)))

(defun import-resource (res)
  (jcall "loadBeanDefinitions" *bean-definition-reader* *load-resource* res))
  
(defun require-resource (res)
  (jcall "requireBeanDefinitions" *bean-definition-reader* *load-resource* res))

(defvar *factory-bean*)

(defun factory-arg (name &optional (*factory-bean* *factory-bean*))
  (jcall "getDependency" *factory-bean* name))

(defmacro define-factory (name-and-args dependencies &body body)
  (let ((name-and-args (ensure-list name-and-args)))
    (destructuring-bind (name &key (class null) (singleton true)) name-and-args
      `(register-bean-definition
        ,name
        (bean "dynaspring.LispFactoryBean"
              :constructor-args ((lambda (*factory-bean*)
                                   ,@body)
                                 ,class)
              :properties
              ("singleton" ,singleton
               "dependencies" (map
                               ,@(let (map)
                                      (dolist (x dependencies)
                                        (if (consp x)
                                            (progn
                                              (push (car x) map)
                                              (push (cadr x) map))
                                            (progn
                                              (push x map)
                                              (push `(ref ,x) map))))
                                      (nreverse map)))))))))

(defun bean-field (bean-name field-name)
  (bean "org.springframework.beans.factory.config.FieldRetrievingFactoryBean"
        :properties ("targetObject" (ref bean-name) "targetField" field-name)))

(defun property-path (pp &optional (bean-factory *bean-factory*))
  "Returns a bean definition whose runtime value is read off <pp>, interpreted as a dot-separated property path."
  (jstatic "makePropertyPathFactoryBean" "dynaspring.support.Util" pp bean-factory))

(defun property-ref (bean pp &optional (bean-factory *bean-factory*))
  (bean "org.springframework.beans.factory.config.PropertyPathFactoryBean"
        :properties ("targetObject" (if (stringp bean) (ref bean) bean)
                     "propertyPath" pp
                     "beanFactory" bean-factory)))

;;;Lists, sets, maps
(defun load-props (&rest resources)
  "Returns a bean which is a java.util.Properties instance loaded from <resources>."
  (when (cl:null resources)
    (error "No resources defined for load-props"))
  (bean "org.springframework.beans.factory.config.PropertiesFactoryBean"
        :properties ("locations" (mapcar #'resource resources))))

(defun merge (mergeable-collection &optional (merge t))
  (let ((coll (convert-value mergeable-collection)))
    (jcall "setMergeEnabled" coll (jbool merge))
    coll))

(defmacro deflist (name (&key (class "java.util.ArrayList") merge)
                   &rest lists)
  (let ((lists (if merge
                   (cons `(get-bean-definition ,name) lists)
                   lists)))
    `(defbean ,name "dynaspring.support.ListFactoryBean"
       :properties ("targetListClass" ,(jclass class) "sourceLists" (list ,@lists)))))

(defmacro defset (name (&key (class "java.util.HashSet") merge)
                  &rest sets)
  (let ((sets (if merge
                  (cons `(get-bean-definition ,name) sets)
                  sets)))
    `(defbean ,name "dynaspring.support.SetFactoryBean"
       :properties ("targetSetClass" ,(jclass class) "sourceSets" (list ,@sets)))))

(defmacro defmap (name (&key (class "java.util.HashMap") merge)
                  &rest maps)
  (let ((maps (if merge
                  (cons `(get-bean-definition ,name) maps)
                  maps)))
    `(defbean ,name "dynaspring.support.MapFactoryBean"
       :properties ("targetMapClass" ,(jclass class) "sourceMaps" (list ,@maps)))))


(defmacro defprops (name (&key (class "java.util.Properties") merge)
                    &rest props)
  `(defmap ,name (:class ,class :merge ,merge)
     ,@(mapcar (lambda (x) (if (resourcep x) (load-props x) x))
               props)))

;;Context namespace
(defun register-annotation-config-processors
    (&optional (ctx *bean-factory*) (source *load-resource*))
  (jstatic "registerAnnotationConfigProcessors" "org.springframework.context.annotation.AnnotationConfigUtils" ctx source))

;;Modularity constructs
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun check-decorated-bean (args name form)
    (apply (lambda (&key constructor-args factory-method factory-bean
                    &allow-other-keys)
             (when (or constructor-args factory-method factory-bean)
               (error ":constructor-args, :factory-method and :factory-bean are not allowed on bean ~A (~S)" name form)))
           args)))

(defmacro import-bean (&whole form
                       name (&key bean context (bean-name name)) &rest args)
  (check-decorated-bean args name form)
  (if bean
    `(defbean ,name ,(jclass "dynaspring.support.Util")
       :constructor-args (,bean)
       :factory-method "importBean"
       ,@args)
    `(defbean ,name null
       :factory-method "getBean"
       :factory-bean ,context
       :constructor-args (,bean-name)
       ,@args)))

(defmacro define-bean-decorator (name bean &rest args)
  `(import-bean ,name (:bean ,bean) ,@args))

(defmacro with-application-context
    ((&optional (context '(jnew "org.springframework.context.support.GenericApplicationContext")))
     &body body)
  `(let* ((*application-context* ,context)
          (*bean-factory*
           (jcall "getDefaultListableBeanFactory" *application-context*))
          (*bean-definition-reader*
           (jnew "dynaspring.LispBeanDefinitionReader" *bean-factory*)))
     ,@body))

(defun refresh (&optional (ctx *application-context*))
  (jcall "refresh" ctx)
  ctx)

(defmacro defcontext
    (name
     (&key (class "org.springframework.context.support.GenericApplicationContext")
           resources parent imports)
     &body body)
  "Defines an application context with optional parent `parent`, loading bean definitions from <resources>, and optionally importing beans from other contexts using <imports>.
  <imports> is a list of lists in the format ([:from] <context-name> [:import] <bean-definition>*), where each <bean-definition> is either a string, or a list in the format (<name-in-the-imported-context> [:as] <name-in-the-target-context>). A string-valued <bean-definition> is equivalent to (<bean-definition> :as <bean-definition>).
  <body> is a series of forms that will be executed while creating the target context.
  DEFCONTEXT can be used to define modular contexts that only import selected beans from other contexts, without sharing any other bean with them. This is particularly useful when combining Spring-configured libraries or modules with interdependencies among themselves: in such a scenario each library or module will have its own private application context, while retaining the possibility to use selected beans from other libraries or modules."
  (let ((imports (mapcar #'(lambda (x) (remove-if #'keywordp x)) imports)))
    `(define-factory ,name
         ((:resources (list ,@(ensure-list resources)))
          ,@(when parent `((:parent ,(ensure-ref parent))))
          ,@(mapcar #'(lambda (x) `(,(car x) ,(ensure-ref (car x)))) imports))
       (with-application-context ((jnew ,class
                                        ,@(when parent `((factory-arg :parent)))))
         (sequence:dosequence (res (factory-arg :resources))
           (import-resource res))
         ,@(loop
              :for import-list :in imports
              :collect
              `(let ((ctx (factory-arg ,(car import-list))))
                 ,@(loop
                      :for import :in (cdr import-list)
                      :collect
                      (let* ((import (if (listp import)
                                         (remove-if #'keywordp import)
                                         (list import import)))
                             (bean-name (car import))
                             (import-name (cadr import)))
                        `(define-factory ,import-name ()
                           (jcall "getBean" ctx ,bean-name))))))
         ,@body
         *application-context*))))

(defmacro defmodule (name interface
                     (&key
                      (factory-class "dynaspring.ApplicationContextProxyFactory")
                      (factory-name (concatenate 'string (to-java-name name) "-factory"))
                      factory-properties
                      (target-object null) (init-method null) (destroy-method null)
                      (target-object-participates-in-lifecyle true)
                      dependencies)
                     &body body)
  "Defines a Spring-backed module defined by an interface. Getter methods in the interface represent beans that are exported from the underlying application context; setter methods represent dependencies of the module which must be provided before the module is initialized. See the Java class dynaspring.ApplicationContextProxyFactory."
  `(progn
     (defbean ,factory-name ,factory-class
       :properties ("applicationContext" (progn ,@body)
                    "proxyInterface" ,interface
                    "targetObject" ,target-object
                    "initMethodName" ,init-method
                    "destroyMethodName" ,destroy-method
                    "targetObjectParticipatesInLifecycle" ,target-object-participates-in-lifecyle
                    ,@factory-properties))
     (defbean ,name ,interface
       :factory-bean ,factory-name :factory-method "getProxy"
       :init-method ,init-method :destroy-method ,destroy-method
       :properties ,dependencies)))